home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PRUS101 / FDATE.PAS < prev    next >
Pascal/Delphi Source File  |  1995-01-11  |  11KB  |  353 lines
  1. UNIT FDATE; { FIDO unit for handling time, date(s) and calender(s) }
  2.  (***************************************************************************
  3.  
  4.             RELEASE 1.03 - as contained in the file PRUS101.LZH
  5.                 by Peter Holschbach, 2:2450/660.3, GERMANY
  6.  
  7.                --------------------------------------------
  8.                 organized for Fido's PASCAL related echoes
  9.                --------------------------------------------
  10.  
  11.      06/16/1994 to 06/18/1994 by Orazio Czerwenka, 2:2450/540.55, GERMANY
  12.      06/18/1994 to --/--/---- by Peter Holschbach, 2:2450/660.3,  GERMANY
  13.  
  14.  
  15.            As far as third party copyrights are not violated this
  16.            source code is hereby placed to the public domain. Use
  17.            it whatever way you want, but use AT YOUR OWN RISK.
  18.  
  19.            In case you should modify the source rather send your
  20.            modifications to the unit's current organizer (see above for
  21.            NM address) than to spread it on your own. This will help to
  22.            keep the unit updated and grant a certain standard to all
  23.            other users as well.
  24.  
  25.            The unit is currently still under work. So it might greatly
  26.            benefit of your participation.
  27.  
  28.            Those who contributed to the following piece of source,
  29.            listed in alphabethical order:
  30.         ================================================================
  31.            Orazio Czerwenka, Peter Holschbach ...
  32.         ================================================================
  33.            YOUR NAME WILL APPEAR HERE IF YOU CONTRIBUTE USEFUL SOURCE.
  34.  
  35.            Credits in your own programs are as welcome as unnecessary.
  36.  
  37.  ***************************************************************************)
  38.  
  39. {$I FDEFINE.DEF}
  40.  
  41. interface
  42.  
  43. const
  44.   European      = 1;
  45.   American      = 2;
  46.   Japanese      = 3;
  47.   TimeSeperator : Char = ':';
  48.   DateSeperator : Char = '.';
  49.  
  50.   DateFormat    : Byte = European;
  51.  
  52.   CDaysOfMonth : Array [0..1] of Array [1..12] of Byte = (
  53.                  (31,28,31,30,31,30,31,31,30,31,30,31),
  54.                  (31,29,31,30,31,30,31,31,30,31,30,31)
  55.                  );
  56.  
  57.   CDayOfWeekAmerican : Array [0..6] of String [3] =
  58.                        ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
  59.  
  60.   CMonthAmerican :     Array [1..12] of string[3] =
  61.    ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
  62.  
  63.   CDayOfWeekGerman  : Array [0..6] of String [3] =
  64.                        ('Son','Mon','Die','Mit','Don','Fre','Sam');
  65.  
  66.   CMonthGerman      :  Array [1..12] of string[3] =
  67.    ('Jan','Feb','Mär','Apr','Mai','Jun','Jul','Aug','Sep','Okt','Nov','Dez');
  68.  
  69.  
  70. function  DayDiff (FYear,FMonth,FDay,TYear,TMonth,TDay : Word) : LongInt;
  71. function  DayNumber (Year,Month,Day : Word):LongInt;
  72. function  DayOfWeek (Year,Month,Day : Word):Byte;
  73. Function  DayOfYear (Year,Month,Day : Word):Word;
  74. function  GetCurrentDateString : String;
  75. Procedure GetDate (Var Year,Month,Day,DayOfWeek : Word);
  76. function  GetDateString (Year,Month,Day : Word) : String;
  77. function  GetCurrentTimeString : String;
  78. Procedure GetTime (Var Hour,Minute,Second,Sec100:Word);
  79. function  GetTimeString (hour,minute,second : Word) : String;
  80. Function  GetCurrentUnixTime : LongInt;
  81. Function  GetUnixTime(Year,Month,Day,Hour,Minute,Second : Word) : LongInt;
  82. function  IsLeapYear (Year : Word): Boolean;
  83. function  ValidDate (Year,Month,Day : Word):Byte;
  84. function  WeekOfYear (Year,Month,Day : Word):Byte;
  85.  
  86. implementation
  87.  
  88. (**************************************************************************)
  89.  
  90. function DayDiff (FYear,FMonth,FDay,TYear,TMonth,TDay : Word) : LongInt;
  91.  
  92. Begin
  93.   DayDiff := DayNumber (TYear,TMonth,TDay) - DayNumber (FYear,FMonth,FDay);
  94. End;
  95.  
  96. {----------------------------------------------------------------------------}
  97.  
  98. function DayNumber (Year,Month,Day : Word):LongInt;
  99. { Original author: Peter Holschbach }
  100.  
  101. Begin
  102.   DayNumber := LongInt (Year-1) * 365 + (Year-1) div 4 - (Year-1) div 100 +
  103.                (Year-1) div 400 + DayOfYear (Year,Month,Day);
  104.                (* Days gone since 0000 *)
  105. End;
  106.  
  107. {----------------------------------------------------------------------------}
  108.  
  109. function DayOfWeek (Year,Month,Day : Word):Byte;
  110. { Original author: Peter Holschbach }
  111.  
  112. Begin
  113.   DayOfWeek := (DayNumber (Year,Month,Day) mod 7);
  114. End;
  115.  
  116. {----------------------------------------------------------------------------}
  117.  
  118. Function DayOfYear (Year,Month,Day : Word):Word;
  119. { Original author: Peter Holschbach }
  120.  
  121. Var LeapYear : Byte;
  122.     Days     : Word;
  123.     L        : Byte;
  124.  
  125. Begin
  126.   Days := 0;
  127.   LeapYear := Byte(IsLeapYear (Year));
  128.   For L:= 1 to Month-1 do Begin   (* count alle the days *)
  129.     Days := Days + CDaysOfMonth [LeapYear,L];
  130.   End;
  131.   DayOfYear := Days + Day;  (* add the days of the month *)
  132. End;
  133.  
  134. {----------------------------------------------------------------------------}
  135. Function GetCurrentDateString : String;
  136. { Original author: Peter Holschbach,
  137.   modifications Orazio Czerwenka }
  138. var Year,
  139.     Month,
  140.     Day,
  141.     DayOfWeek      : Word;
  142.  
  143. Begin
  144.   GetDate (Year,Month,Day,DayOfWeek);
  145.   GetCurrentDateString := GetDateString (Year,Month,Day);
  146. End;
  147.  
  148. {----------------------------------------------------------------------------}
  149. Procedure GetDate (Var Year,Month,Day,DayOfWeek: Word);
  150. { Original author: Peter Holschbach}
  151.  
  152. Begin
  153.   Asm
  154.     MOV AH,$2A   (* Get Date *)
  155.     INT $21
  156.     LES BX,Year
  157.     MOV ES:[BX],CX
  158.     XOR AH,AH        (* set AH to Zero *)
  159.     LES BX,DayOfWeek
  160.     MOV ES:[BX],AX
  161.     LES BX,Month
  162.     MOV AL,DH
  163.     MOV ES:[BX],AX   (* is WORD ! *)
  164.     LES BX,Day
  165.     MOV AL,DL
  166.     MOV ES:[BX],AX
  167.   End;
  168. End;
  169.  
  170. {----------------------------------------------------------------------------}
  171.  
  172. Function GetDateString (Year,Month,Day : Word): String;
  173. { Original author: Peter Holschbach}
  174.  
  175. var
  176.     Tmp         : String;
  177.     TmpDate     : String;
  178.     L           : Word;
  179.  
  180. Begin
  181.   Case DateFormat of
  182.     European: begin Str (Day:2,TmpDate); Str (Month:2,Tmp); end;
  183.     American: begin Str (Month:2,TmpDate); Str (Day:2,Tmp); end;
  184.     Japanese: begin Str ((Year Mod 100):2,TmpDate); Str (Month:2,Tmp); end;
  185.   End;
  186.   TmpDate := TmpDate + DateSeperator + Tmp;
  187.   Case DateFormat of
  188.     European,
  189.     American: Str ((Year Mod 100):2,Tmp);
  190.     Japanese: Str (Day:2,Tmp);
  191.   End;
  192.   TmpDate := TmpDate + DateSeperator + Tmp;
  193.   For L := 1 to Length (TmpDate) do Begin
  194.     If TmpDate [L] = ' ' then TmpDate [L] := '0';
  195.   End;
  196.   GetDateString := TmpDate;
  197. End;
  198.  
  199. {----------------------------------------------------------------------------}
  200.  
  201. Function GetCurrentTimeString : String;
  202. { Original author: Peter Holschbach}
  203.  
  204. var Hour,
  205.     Minute,
  206.     Second,
  207.     Sec100: Word;
  208.  
  209.  
  210. Begin
  211.   GetTime (Hour,Minute,Second,Sec100);
  212.   GetCurrentTimeString := GetTimeString (Hour,Minute,Second);
  213. End;
  214. {----------------------------------------------------------------------------}
  215.  
  216. Procedure GetTime (Var Hour,Minute,Second,Sec100:Word);
  217. { Original author: Peter Holschbach }
  218.  
  219. Begin
  220.   Asm
  221.     MOV AH,$2C   (* Get Time *)
  222.     INT $21
  223.     XOR AH,AH
  224.     LES BX,Hour
  225.     MOV AL,CH
  226.     MOV ES:[BX],AX
  227.     LES BX,Minute
  228.     MOV AL,CL
  229.     MOV ES:[BX],AX
  230.     LES BX,Second
  231.     MOV AL,DH
  232.     MOV ES:[BX],AX
  233.     LES BX,Sec100
  234.     MOV AL,DL
  235.     MOV ES:[BX],AX
  236.   End;
  237. end;
  238.  
  239. {----------------------------------------------------------------------------}
  240.  
  241. Function GetTimeString (hour,minute,second : Word) : String;
  242. { Original author: Peter Holschbach,
  243.   modifications Orazio Czerwenka }
  244. var
  245.     Tmp         : String;
  246.     TmpTime     : String;
  247.     L           : Word;
  248.  
  249. Begin
  250.   Str (Hour:2,TmpTime);
  251.   Str (Minute:2,Tmp);
  252.   TmpTime := TmpTime + TimeSeperator + Tmp;
  253.   Str (Second:2,Tmp);
  254.   TmpTime := TmpTime + TimeSeperator + Tmp;
  255.   For L := 1 to Length (TmpTime) do Begin
  256.     If TmpTime [L] = ' ' then TmpTime [L] := '0';
  257.   End;
  258.   GetTimeString := TmpTime;
  259. End;
  260.  
  261. {----------------------------------------------------------------------------}
  262.  
  263. Function  GetCurrentUnixTime : LongInt;
  264. { Original author: Peter Holschbach }
  265.  
  266. var Year,
  267.     Month,
  268.     Day,
  269.     DayOfWeek,
  270.     Hour,
  271.     Minute,
  272.     Second,
  273.     Sec100: Word;
  274.  
  275. Begin
  276.   GetTime (Hour,Minute,Second,Sec100);
  277.   GetDate (Year,Month,Day,DayOfWeek);
  278.   GetCurrentUnixTime := GetUnixTime(Year,Month,Day,Hour,Minute,Second);
  279. End;
  280.  
  281.  
  282. {----------------------------------------------------------------------------}
  283. Function  GetUnixTime(Year,Month,Day,Hour,Minute,Second : Word) : LongInt;
  284. { Original author: Peter Holschbach }
  285.  
  286. Var Days : LongInt;
  287.  
  288. Begin
  289.   Days := DayDiff (1970,1,1,Year,Month,Day);
  290.   GetUnixTime := LongInt(Days) * 24 * 60 * 60 + 60*60*LongInt(Hour) + 60*Minute + Second;
  291. End;
  292.  
  293. {----------------------------------------------------------------------------}
  294.  
  295. function IsLeapYear (Year : Word): Boolean;
  296. { Original author: Peter Holschbach }
  297.  
  298. Begin
  299.   IsLeapYear := ((Year Mod 4) = 0) AND ( (NOT((Year MOD 100) = 0)) OR
  300.                                               ((Year MOD 400) = 0) );
  301. End;
  302.  
  303. {----------------------------------------------------------------------------}
  304.  
  305. function  ValidDate (Year,Month,Day : Word):Byte;
  306. { Original author: Peter Holschbach}
  307.  
  308. Begin
  309.   If (Month = 0) or (Month > 12) then Begin
  310.     ValidDate := 2;
  311.     Exit;
  312.   End;
  313.   If (Day = 0) or (Day < CDaysOfMonth [Byte(IsLeapYear (Year)),Month]) then Begin
  314.     ValidDate := 3;
  315.     Exit;
  316.   End;
  317. End;
  318.  
  319. {----------------------------------------------------------------------------}
  320.  
  321. function WeekOfYear (Year,Month,Day : Word):Byte;
  322. { Original author: Peter Holschbach}
  323.  
  324.         (* days to next monday/thuesday from any day of week *)
  325. Const   CNextMon : Array [0..6] Of Byte = (1,0,6,5,4,3,2);
  326.         CNextThu: Array [0..6] Of Byte = (4,3,2,1,0,6,5);
  327.  
  328. Var
  329.     Week  : Integer;
  330.  
  331. Begin
  332.     (* test if the year starts with the first week *)
  333.   If CNextThu [DayOfWeek (Year,1,1)] > 3 then Begin
  334.     week := (Integer(DayOfYear(Year,Month,Day)) - CNextMon [DayOfWeek (Year,1,1)] + 6) div 7;
  335.   End
  336.   Else Begin
  337.     week := (Integer(DayOfYear(Year,Month,Day)) - CNextMon [DayOfWeek (Year,1,1)] + 6) div 7+1;
  338.   End;
  339.   If Week <= 0 then Begin
  340.     (* the given date is in the last week of the previous year *)
  341.     Week := WeekOfYear (year-1,12,31);
  342.   End;
  343.   WeekOfYear := Week;
  344. End;
  345.  
  346. {----------------------------------------------------------------------------}
  347. (**************************************************************************)
  348.  
  349. end.
  350.  
  351. 1.02 -> 1.03
  352.   - CMonthAmerican und CMonthGerman neu
  353.